home *** CD-ROM | disk | FTP | other *** search
/ InfoMagic Internet Tools 1993 July / Internet Tools.iso / RockRidge / mail / vm / vm-5.33beta / vm-group.el < prev    next >
Encoding:
Text File  |  1991-04-06  |  7.9 KB  |  221 lines
  1. ;;; Commands to rearrange (group) message presentation
  2. ;;; Copyright (C) 1989, 1990 Kyle E. Jones
  3. ;;;
  4. ;;; This program is free software; you can redistribute it and/or modify
  5. ;;; it under the terms of the GNU General Public License as published by
  6. ;;; the Free Software Foundation; either version 1, or (at your option)
  7. ;;; any later version.
  8. ;;;
  9. ;;; This program is distributed in the hope that it will be useful,
  10. ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  11. ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  12. ;;; GNU General Public License for more details.
  13. ;;;
  14. ;;; You should have received a copy of the GNU General Public License
  15. ;;; along with this program; if not, write to the Free Software
  16. ;;; Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
  17.  
  18. (defun vm-group-by (compare-function)
  19.   (let (buckets bp cons (mp vm-message-list))
  20.     (while mp
  21.       (setq bp buckets)
  22.       (catch 'found
  23.     (while bp
  24.       (if (funcall compare-function (car mp) (car (car bp)))
  25.           (progn
  26.         (setq cons mp
  27.               mp (cdr mp))
  28.         (setcdr cons nil)
  29.         (setcar bp (nconc cons (car bp)))
  30.         (throw 'found t)))
  31.       (setq bp (cdr bp)))
  32.     (setq cons mp
  33.           mp (cdr mp))
  34.     (setcdr cons nil)
  35.     (setq buckets (cons cons buckets))))
  36.     (setq vm-message-list
  37.       (apply 'nconc (nreverse (mapcar 'nreverse buckets)))
  38.       vm-message-order-changed t)
  39.     (vm-reverse-link-messages)
  40.     (and (eq vm-retain-message-order t) (not vm-folder-read-only)
  41.      (vm-set-buffer-modified-p t))))
  42.  
  43. (defconst vm-group-by-subject-closure (cons t t))
  44.  
  45. (defun vm-group-by-subject (m1 m2)
  46.   (let ((subject (vm-su-subject m1)))
  47.     (if (eq subject (car vm-group-by-subject-closure))
  48.     (setq subject (cdr vm-group-by-subject-closure))
  49.       (setcar vm-group-by-subject-closure subject)
  50.       (if (string-match "^\\(re: *\\)+" subject)
  51.       (setq subject (substring subject (match-end 0))))
  52.       (if (string-match " +$" subject)
  53.       (setq subject (substring subject 0 (match-beginning 0))))
  54.       (setq subject (concat "^\\(re: *\\)*"
  55.                 (regexp-quote subject)
  56.                 " *$"))
  57.       (setcdr vm-group-by-subject-closure subject))
  58.     (string-match subject (vm-su-subject m2))))
  59.  
  60. (defun vm-group-by-author (m1 m2)
  61.   (string= (vm-su-full-name m1) (vm-su-full-name m2)))
  62.  
  63. (defun vm-group-by-recipient (m1 m2)
  64.   (equal (vm-su-to-names m1) (vm-su-to-names m2)))
  65.  
  66. (defun vm-group-by-date-sent (m1 m2)
  67.   (and (string= (vm-su-monthday m1) (vm-su-monthday m2))
  68.        (string= (vm-su-month m1) (vm-su-month m2))
  69.        (string= (vm-su-year m1) (vm-su-year m2))))
  70.  
  71. (defun vm-revert-to-physical-order ()
  72.   (let ((curr (car vm-message-pointer))
  73.     (last (car vm-last-message-pointer)))
  74.     (setq curr nil last nil)
  75.     (setq vm-message-list
  76.       (sort vm-message-list
  77.         (function
  78.          (lambda (p q) (< (vm-start-of p) (vm-start-of q)))))
  79.       vm-message-order-changed vm-message-order-stuffed)
  80.     (vm-reverse-link-messages)
  81.     (and vm-message-order-changed
  82.      (eq vm-retain-message-order t)
  83.      (not vm-folder-read-only)
  84.      (vm-set-buffer-modified-p t))))
  85.  
  86. (defun vm-group-messages (grouping)
  87.   "Group messages by the argument GROUPING.
  88. Interactively this argument is prompted for in the minibuffer,
  89. with completion."
  90.   (interactive
  91.    (list 
  92.     (completing-read
  93.      (format "Group messages by (default %s): "
  94.          (or vm-group-by "physical-order"))
  95.      vm-supported-groupings-alist 'identity t)))
  96.   (vm-select-folder-buffer)
  97.   (vm-check-for-killed-summary)
  98.   (if (equal grouping "")
  99.       (setq grouping vm-group-by))
  100.   (cond ((and grouping (not (stringp grouping)))
  101.      (error "Unsupported grouping: %s" grouping))
  102.     ((equal grouping "physical-order")
  103.      (setq grouping nil)))
  104.   (if grouping
  105.       (let ((group-function (intern (concat "vm-group-by-" grouping))))
  106.     (if (not (fboundp group-function))
  107.         (error "Unsupported grouping: %s" grouping))
  108.     (vm-revert-to-physical-order)
  109.     (message "Grouping messages by %s..." grouping)
  110.     (vm-group-by group-function)
  111.     (message "Grouping messages by %s... done" grouping)
  112.     (setq vm-current-grouping grouping
  113.           vm-numbering-redo-start-point t
  114.           vm-summary-redo-start-point t))
  115.     (vm-revert-to-physical-order)
  116.     (setq vm-current-grouping grouping
  117.       vm-numbering-redo-start-point t
  118.       vm-summary-redo-start-point t)
  119.     (if (interactive-p)
  120.     (message "Reverted to folder's physical ordering")))
  121.   (vm-update-summary-and-mode-line))
  122.  
  123. (defun vm-move-message-forward (count)
  124.   "Move a message forward in a VM folder.
  125. Prefix arg COUNT causes the current message to be moved COUNT messages forward.
  126. A negative COUNT causes movement to be backward instead of forward.
  127. COUNT defaults to 1.  The current message remains selected after being
  128. moved."
  129.   (interactive "p")
  130.   (vm-follow-summary-cursor)
  131.   (vm-select-folder-buffer)
  132.   (vm-check-for-killed-summary)
  133.   (vm-error-if-folder-empty)
  134.   (let* ((ovmp vm-message-pointer) vmp-prev ovmp-prev
  135.      (vm-message-pointer vm-message-pointer)
  136.      (direction (if (> count 0) 'forward 'backward))
  137.      (count (vm-abs count)))
  138.     (while (not (zerop count))
  139.       (vm-move-message-pointer direction)
  140.       (vm-decrement count))
  141.     (if (> (string-to-int (vm-number-of (car vm-message-pointer)))
  142.        (string-to-int (vm-number-of (car ovmp))))
  143.     (setq vm-message-pointer (cdr vm-message-pointer)))
  144.     (if (eq vm-message-pointer ovmp)
  145.     ()
  146.       (if (null vm-message-pointer)
  147.       (setq vmp-prev (vm-last vm-message-list))
  148.     (setq vmp-prev (vm-reverse-link-of (car vm-message-pointer))))
  149.       (setq ovmp-prev (vm-reverse-link-of (car ovmp)))
  150.       (if ovmp-prev
  151.       (progn
  152.         (setcdr ovmp-prev (cdr ovmp))
  153.         (and (cdr ovmp)
  154.          (vm-set-reverse-link-of (car (cdr ovmp)) ovmp-prev)))
  155.     (setq vm-message-list (cdr ovmp))
  156.     (vm-set-reverse-link-of (car vm-message-list) nil))
  157.       (if vmp-prev
  158.       (progn
  159.         (setcdr vmp-prev ovmp)
  160.         (vm-set-reverse-link-of (car ovmp) vmp-prev))
  161.     (setq vm-message-list ovmp)
  162.     (vm-set-reverse-link-of (car vm-message-list) nil))
  163.       (setcdr ovmp vm-message-pointer)
  164.       (and vm-message-pointer
  165.        (vm-set-reverse-link-of (car vm-message-pointer) ovmp))
  166.       (setq vm-message-order-changed t)
  167.       (and (eq vm-retain-message-order t) (not vm-folder-read-only)
  168.        (vm-set-buffer-modified-p t))
  169.       (cond ((null ovmp-prev)
  170.          (setq vm-numbering-redo-start-point vm-message-list
  171.            vm-numbering-redo-end-point vm-message-pointer
  172.            vm-summary-pointer (car vm-message-list)))
  173.         ((null vmp-prev)
  174.          (setq vm-numbering-redo-start-point vm-message-list
  175.            vm-numbering-redo-end-point (cdr ovmp-prev)
  176.            vm-summary-pointer (car ovmp-prev)))
  177.         ((or (not vm-message-pointer)
  178.          (< (string-to-int (vm-number-of (car ovmp-prev)))
  179.             (string-to-int (vm-number-of (car vm-message-pointer)))))
  180.          (setq vm-numbering-redo-start-point (cdr ovmp-prev)
  181.            vm-numbering-redo-end-point (cdr ovmp)
  182.            vm-summary-pointer (car (cdr ovmp-prev))))
  183.         (t
  184.          (setq vm-numbering-redo-start-point ovmp
  185.            vm-numbering-redo-end-point (cdr ovmp-prev)
  186.            vm-summary-pointer (car ovmp-prev))))
  187.       (if vm-summary-buffer
  188.       (let (list mp)
  189.         (vm-copy-local-variables vm-summary-buffer 'vm-summary-pointer)
  190.         (setq vm-need-summary-pointer-update t)
  191.         (setq mp vm-numbering-redo-start-point)
  192.         (while (not (eq mp vm-numbering-redo-end-point))
  193.           (vm-mark-for-display-update (car mp))
  194.           (setq list (cons (car mp) list)
  195.             mp (cdr mp)))
  196.         (vm-mapc
  197.          (function
  198.           (lambda (m p)
  199.         (vm-set-su-start-of m (car p))
  200.         (vm-set-su-end-of m (car (cdr p)))))
  201.          (setq list (nreverse list))
  202.          (sort
  203.           (mapcar
  204.            (function
  205.         (lambda (p)
  206.           (list (vm-su-start-of p) (vm-su-end-of p))))
  207.            list)
  208.           (function
  209.            (lambda (p q)
  210.          (< (car p) (car q))))))))))
  211.   (vm-update-summary-and-mode-line))
  212.  
  213. (defun vm-move-message-backward (count)
  214.   "Move a message backward in a VM folder.
  215. Prefix arg COUNT causes the current message to be moved COUNT
  216. messages backward.  A negative COUNT causes movement to be
  217. forward instead of backward.  COUNT defaults to 1.  The current
  218. message remains selected after being moved."
  219.   (interactive "p")
  220.   (vm-move-message-forward (- count)))
  221.